home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
HAM Radio 1997
/
HAM Radio 1997.iso
/
vcls
/
rtf
/
rtf.pas
next >
Wrap
Pascal/Delphi Source File
|
1996-04-08
|
6KB
|
304 lines
{Attached is an attempt at a Pascal RTF reader, which I abandoned in
favor of C. The approach is to treat RTF as a language and write
a recursive descent parser for it. The C version works quite well.
The Pascal version may serve some simple purpose. It's yours to
use freely.}
program rtf;
uses crt;
const
BUFSIZE = 1024;
BEGIN_CWORD = #$DC;
BEGIN_GROUP = #$FB;
END_GROUP = #$FD;
TOKENSET : set of char = [BEGIN_CWORD,BEGIN_GROUP,END_GROUP];
var
current_ch : char;
current_word : string[80];
current_parm : integer;
rtf_version : integer;
rtf_charset : string[8];
default_font : integer;
margin : integer;
index : integer;
buffer : array [1..BUFSIZE] of char;
f : file;
tagfile : text;
procedure item; forward;
procedure group; forward;
function o(ch: char) : char;
begin
case ch of
BEGIN_GROUP: o := '{';
END_GROUP: o := '}';
BEGIN_CWORD: o := '\';
else o := ch;
end;
end;
procedure getch;
var
ch : char;
result : integer;
function nextch : char;
begin
if index >= BUFSIZE then
begin
BlockRead(f, buffer, BUFSIZE, result);
if result = 0 then
begin
writeln('Unexpected end of RTF file');
halt;
end;
index := 0;
end;
inc(index);
nextch := buffer[index];
end;
begin
ch := nextch;
case ch of
'\':
begin
ch := nextch;
if ch in ['{','}','\'] then
current_ch := ch
else
begin
current_ch := BEGIN_CWORD;
dec(index);
end;
end;
'{': current_ch := BEGIN_GROUP;
'}': current_ch := END_GROUP;
else current_ch := ch;
end;
end;
procedure accept(expected: char; echo: boolean);
begin
if expected <> current_ch then
begin
writeln('SYNTAX: expected ',o(expected),' found ',o(current_ch));
end
else
begin
if echo and (current_ch in [' '..'~']+TOKENSET) then
write(o(current_ch));
getch;
end;
end;
procedure accept_alpha(var alpha: string);
begin
alpha := '';
while current_ch in ['A'..'Z','a'..'z'] do
begin
alpha := alpha + current_ch;
accept(current_ch, TRUE);
end;
end;
procedure accept_num(var num: integer);
var
value : longint;
signed : boolean;
begin
if current_ch = '-' then
begin
signed := TRUE;
accept('-',TRUE);
end
else
signed := FALSE;
value := 0;
while current_ch in ['0'..'9'] do
begin
value := value*10 + ord(current_ch)-ord('0');
accept(current_ch, TRUE);
end;
if value > 32767 then
begin
writeln('Integer overflow');
value := 32767;
end;
if signed then
num := -value
else
num := value;
end;
procedure control_word(var spelling: string; var parm: integer);
begin
accept(BEGIN_CWORD,TRUE);
accept_alpha(spelling);
accept_num(parm);
if current_ch = ' ' then
accept(' ',TRUE);
writeln(tagfile, spelling:10, parm:10);
end;
procedure indent(amount: integer);
var
i : integer;
begin
inc(margin, amount);
writeln;
for i:= 1 to margin do
write(' ');
end;
procedure content;
begin
indent(2);
accept(BEGIN_GROUP,TRUE);
indent(2);
while current_ch <> END_GROUP do
begin
if current_ch = ';' then
begin
accept(current_ch, TRUE);
indent(0);
end
else if current_ch = BEGIN_GROUP then
begin
content;
end
else if current_ch = BEGIN_CWORD then
begin
item;
end
else
accept(current_ch, TRUE);
end;
indent(-2);
accept(END_GROUP, TRUE);
indent(-2);
end;
procedure item;
begin
repeat
if current_ch = BEGIN_GROUP then
begin
content;
end
else if current_ch = ';' then
begin
accept(';', TRUE);
indent(0);
end
else
begin
while not (current_ch in [BEGIN_GROUP,END_GROUP,';']) do
accept(current_ch, TRUE);
end;
until not (current_ch in [BEGIN_GROUP,';',BEGIN_CWORD]);
end;
procedure content1;
var
alpha : string[80];
parm : integer;
begin
while (current_ch <> END_GROUP) do
begin
case current_ch of
BEGIN_GROUP:
group;
BEGIN_CWORD:
control_word(alpha, parm);
else
begin
{writeln('ERROR: unknown token: ',o(current_ch));}
accept(current_ch, TRUE);
end;
end;
end;
end;
procedure group;
begin
indent(2);
accept(BEGIN_GROUP, TRUE);
indent(2);
content1;
indent(-2);
accept(END_GROUP, TRUE);
indent(-2);
end;
procedure version;
var
alpha : string[80];
begin
control_word(alpha, rtf_version);
if alpha <> 'rtf' then
begin
writeln('Not an RTF file');
halt;
end;
end;
procedure character_set;
var
parm : integer;
begin
control_word(rtf_charset, parm);
end;
procedure rtfile;
begin
accept(BEGIN_GROUP, TRUE);
indent(2);
version;
character_set;
content1;
indent(-2);
accept(END_GROUP, TRUE);
end;
begin
ClrScr;
margin := 0;
assign(f, ParamStr(1));
reset(f, 1);
assign(output, '');
rewrite(output);
assign(tagfile, 'tagfile.dat');
rewrite(tagfile);
index := BUFSIZE;
getch;
rtfile;
end.
+-------------------------------------------------+
| John Day
| Computer Science Innovations,Inc
| Principal Engineer PHONE: (407) 676-2923 ext:410
| Melbourne, Fl FAX: (407) 676-3255
| WWW: http://www.csihq.com
| EMAIL: jday@csihq.com
+--------------------------------------------------+